perm filename BBX.F4[MSS,LCS] blob
sn#249491 filedate 1976-11-27 generic text, type T, neo UTF8
00100 SUBROUTINE PT2
00200 INTEGER VALID
00300 DIMENSION VALID(6),BARS(1),JBAR(1),JRN(1),MBAR(1)
00400 DATA JLINE/140/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/,DIV/4./
00500 C JLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
00600
00700 C ADD MORE TO VALID LATER *****
00800 COMMON /FIN/LBAR,METR,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
00900 1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /MNX/MIN,MAX,JT
01000 COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK,
01100 1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4) /KBAR/KBAR(512)
01200 1 /RSP/KNM(10),ENDLN,N,NAME,NMPG,T
01300 COMMON RS,JA,RA,R,RB,RQ(15),KQ,NQ,JQ,JJQ,KBQ,NAQ
01400 COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1) /SIZE/SIZE
01500 COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,ITRANS,I,RXQ
01600 1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(50)
01700 EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5)),(KT,KBAR)
01800 1,(R8,RQ(6)),(R9,RQ(7)),(JRN,RN),(MBAR,RN(1000))
01900 1,(LCNT,IV(45)),(NDPY,IV(46)),(TOT,KBAR(2)),(JBAR,BARS,KBAR(4))
02000 C TRNSP'S Bb, F, BBb, A, G, Eb.
02100 145 FORMAT(F,2I)
02200 CCC IF(RS.NE.'OLD')GO TO 2000
02300 CALL GETEXT('BARS','PAG')
02400 CALL EXTIN(KBAR,512)
02500 CALL EXTIN(RSTFAC,128)
02600 2000 TYPE 144,RSTJ2
02700 CC144 FORMAT(' STAFF SIZE, TRANSP. '$)
02800 144 FORMAT(' STAFF SIZE='F4.2,' CHANGE TO '$)
02900 ACCEPT 145,SIZE,ITRANS
03000 DSK=0
03100 C ****** TEMPORARY ****** DSK
03200 IF(ITRANS.NE.0)DSK=-1
03300 IF(SIZE.EQ.0)SIZE=RSTJ2
03400 SIZE=SIZE/RSTJ2
03500 101 JTOT=0
03600 ITOT=0
03700 DO 22 K=1,KT
03800 JJ=BARS(K)*SIZE+.5
03900 ITOT=ITOT+JJ
04000 JBAR(K)=JJ
04100 22 JTOT=JTOT+JJ
04200 ITOT=TOT*SIZE
04300 CC22 JBAR(K)=BARS(K)*SIZE+.5
04400 CC TOT=TOT*SIZE
04500 33 IF(RSTJ2.EQ.0)RSTJ2=1
04600 RA=JPG*SIZE*RSTJ2
04700 MPG=10./RA
04800 C MPG=NUM OF BRACES PER PAGE.
04900 SPG=10./MPG
05000 C SPG IS SPACE TO BE SET ABOVE STAFF 0
05100 RS=SIZE*17
05200 RA=(RSTJ2*SIZE)/RPSZ(1)
05300 DO 141 K=1,JPG
05400 RB=RSTNUM(K)-1
05500 C ADJUSTS DIST. BETWEEN STAVES DEPENDING ON SIZE FACTOR.
05600 RHGT(K)=RHGT(K)+RB*(RS-17)
05700 141 RPSZ(K)=RPSZ(K)*RA
05800 LPG=JPG
05900 IF(MOD(ITRANS,7).EQ.0)GO TO 140
06000 DO 40 L=1,6
06100 40 IF(ITRANS.EQ.VALID(L))GO TO 140
06200 TYPE 240
06300 GO TO 2000
06400 240 FORMAT(' THIS TRANSP NOT OFFERED')
06500
06600 140 TYPE 90,KT
06700 RA=0
06800 90 FORMAT(' TOTAL BAR LINES='I3/' NUMBER OF BARS PER LINE')
06900
07000 JT=ITOT/JLINE
07100 C USE JLINE (140 FOR NOW) AS SUGGESTED LINE LENGTH
07200 16 NT=JT
07300 L=0
07400 CC JTOT=TOT+.5
07500 KTOT=JTOT
07600 KAV=JTOT/JT
07700
07800 LMIN=-1
07900 LMAX=10000
08000 LJ=0
08100 NJ=0
08200 LMM=-1
08300 LDIF=10000
08400 NBAR(1)=1
08500 J=1
08600 3 M=1
08700 JAV=KTOT/NT
08800 K=JBAR(J)
08900 1 J=J+1
09000 IF(J.GT.KT)GO TO 2
09100 N=JBAR(J)
09200 IF(K+N/2.GE.JAV)GO TO 2
09300 M=M+1
09400 K=K+N
09500 GO TO 1
09600 2 L=L+1
09700 KTOT=KTOT-K
09800 NT=NT-1
09900 JRN(L)=K
10000 NBAR(L+1)=J
10100 IF(NT.GT.0)GO TO 3
10200 5 MAX=0
10300 MIN=10000
10400
10500 DO 7 L=1,JT
10600 K=JRN(L)
10700 IF(K.LE.MAX)GO TO 6
10800 MAX=K
10900 MX=L
11000 6 IF(K.GE.MIN)GO TO 7
11100 MIN=K
11200 MN=L
11300 7 CONTINUE
11400
11500 J=MAX-MIN
11600 IF(MAX.GE.LMAX.AND.J.GE.LDIF)GO TO 9
11700 IF(MIN.GT.LMIN)LMIN=MIN
11800 IF(MAX.LT.LMAX)LMAX=MAX
11900 IF(J.LT.LDIF)LDIF=J
12000 CALL STORE
12100 C SAVE NBAR INFO IN MBAR
12200
12300 IF(MX.LT.MN)GO TO 32
12400 JJ=0
12500 JM=-1
12600 JK=1
12700 23 K=NBAR(MX+JJ)-JJ
12800 C NEXT RIPPLES THE BARS, FROM MAX TO MIN.
12900 MM=JBAR(K)
13000 JRN(MX)=JRN(MX)-MM
13100 JRN(MX+JM)=JRN(MX+JM)+MM
13200 NBAR(MX+JJ)=K+JK
13300 MX=MX+JM
13400 IF(JJ.NE.0)GO TO 223
13500 IF(MX.GT.MN)GO TO 23
13600 GO TO 5
13700 223 IF(MX.LT.MN)GO TO 23
13800 GO TO 5
13900 32 JJ=1
14000 JM=1
14100 JK=0
14200 GO TO 23
14300 9 CALL GET
14400 IDIF=10000
14500 JJT=JT-1
14600 104 CALL MNMX(IDIF)
14700 108 DO 102 J=1,JJT
14800 IF(JRN(J).LE.KAV)GO TO 102
14900 C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
15000 I=NBAR(J+1)-1
15100 IF(I.EQ.NBAR(J))GO TO 102
15200 C WE'RE DOWN TO ONE BAR
15300 JJ=JRN(J)-JBAR(I)
15400 C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
15500 IF(JJ.LT.MIN)GO TO 102
15600 KK=JRN(J+1)+JBAR(I)
15700 IF(KK.GT.MAX)GO TO 103
15800 C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
15900 CALL MINMAX
16000 105 JRN(J)=JJ
16100 JRN(J+1)=KK
16200 NBAR(J+1)=NBAR(J+1)-1
16300 GO TO 104
16400 103 IF(J.EQ.JJT)GO TO 102
16500 NN=KK
16600 DO 106 K=J+1,JJT
16700 LL=NBAR(K+1)-1
16800 C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
16900 MM=NN-JBAR(LL)
17000 IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 102
17100 NN=JBAR(LL)+JRN(K+1)
17200 106 IF(NN.LE.MAX)GO TO 105
17300 102 CONTINUE
17400 204 CALL MNMX(IDIF)
17500 208 DO 202 J=JT,2,-1
17600 IF(JRN(J).LE.KAV)GO TO 202
17700 C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
17800 I=NBAR(J)
17900 IF(I-1.EQ.NBAR(J-1))GO TO 202
18000 C WE'RE DOWN TO ONE BAR
18100 JJ=JRN(J)-JBAR(I)
18200 C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
18300 IF(JJ.LT.MIN)GO TO 202
18400 KK=JRN(J-1)+JBAR(I)
18500 IF(KK.GT.MAX)GO TO 203
18600 C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
18700 CALL MINMAX
18800 205 JRN(J)=JJ
18900 JRN(J-1)=KK
19000 NBAR(J)=NBAR(J)+1
19100 GO TO 204
19200 203 IF(J.EQ.2)GO TO 202
19300 NN=KK
19400 DO 206 K=J-1,2,-1
19500 LL=NBAR(K)
19600 C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
19700 MM=NN-JBAR(LL)
19800 IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 202
19900 NN=JBAR(LL)+JRN(K-1)
20000 206 IF(NN.LE.MAX)GO TO 205
20100 202 CONTINUE
20200
20300 CALL MINMAX
20400 IDIF=MAX-MIN
20500 CALL STORE
20600 400 MX=MAX+5
20700 JR=1
20800 C JR = HOW MANY BARS TO RIPPLE
20900 I=MAX-MIN
21000 IF(I.GT.IDIF)GO TO 402
21100 CALL STORE(JT)
21200 IDIF=I
21300 402 DO 401 J=1,JT
21400 401 IF(JRN(J).EQ.MIN)GO TO 408
21500 C TRY RIPPLE EACH WAY FROM SMALLEST VALUE
21600 408 IF(J.EQ.JT)GO TO 508
21700 C RIPPLE FORWARD FIRST
21800 I=NBAR(J+1)
21900 JJ=JRN(J)+JBAR(I)
22000 IF(JJ.GT.MX)GO TO 508
22100 C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
22200 NN=JRN(J+1)-JBAR(I)
22300 IF(NN.LT.MIN)GO TO 404
22400 C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
22500 JRN(J)=JJ
22600 JRN(J+1)=NN
22700 NBAR(J+1)=I+1
22800 415 CALL MINMAX
22900 C NOW GO BACK AND TRY AGAIN.
23000 GO TO 400
23100
23200 405 JRN(J)=JJ
23300
23400 DO 422 IB=J+1,N
23500 LB=NBAR(IB)
23600 JB=JRN(IB)-JBAR(LB)
23700 NBAR(IB)=LB+1
23800 IF(JB.LT.MIN)GO TO 421
23900 JRN(IB)=JB
24000 GO TO 415
24100
24200 421 IBB=IB+1
24300 LC=NBAR(IBB)
24400 JB=JB+JBAR(LC)
24500 IF(JB.GT.MIN)GO TO 422
24600 C NOW ADD A SECOND BAR
24700 JRN(IBB)=JRN(IBB)-JBAR(LC)
24800 LC=LC+1
24900 JB=JB+JBAR(LC)
25000 NBAR(IBB)=LC
25100
25200 422 JRN(IB)=JB
25300 NBAR(IBB)=LC+1
25400 JRN(IBB)=JRN(IBB)-JBAR(LC)
25500 GO TO 415
25600 C NOW GO BACK AND TRY AGAIN.
25700
25800 404 IF(J.EQ.JJT)GO TO 508
25900 DO 406 N=J+1,JJT
26000 LL=NBAR(N+1)
26100 MM=NN+JBAR(LL)
26200 IF(MM.GT.MX)GO TO 508
26300 IF(MM.GT.MIN)GO TO 409
26400 C NEXT TO RIPPLE 2 BARS!
26500 412 MN=MM+JBAR(LL+1)
26600 C ADD ON A SECOND BAR
26700 IF(MN.GT.MX)GO TO 508
26800 C DON'T WORRY ABOUT IT BEING TOO SMALL (YET)
26900 NN=JRN(N+1)-JBAR(LL)-JBAR(LL+1)
27000 IF(NN.GT.MIN)GO TO 405
27100 GO TO 406
27200
27300 409 NN=JRN(N+1)-JBAR(LL)
27400 IF(NN.GE.MIN)GO TO 405
27500 406 CONTINUE
27600
27700 C TRY RIPPLE EACH WAY FROM SMALLEST VALUE
27800 508 IF(J.EQ.1)GO TO 502
27900 IF(J.NE.LJ)GO TO 150
27950 IF(MX-MN.EQ.LMM)GO TO 502
28000 C THIS SHOULD AVOID GETTING INTO A LOOP
28100 150 LJ=J
28200 LMM=MX-MN
28300 C RIPPLE BACK NOW
28400 I=NBAR(J)-1
28500 JJ=JRN(J)+JBAR(I)
28600 IF(JJ.GT.MX)GO TO 502
28700 C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
28800 NN=JRN(J-1)-JBAR(I)
28900 IF(NN.LT.MIN)GO TO 504
29000 C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
29100 JRN(J)=JJ
29200 JRN(J-1)=NN
29300 NBAR(J)=I
29400 GO TO 415
29500 505 JRN(J)=JJ
29600 DO 522 IB=J-1,N,-1
29700 LB=NBAR(IB+1)-1
29800 JB=JRN(IB)-JBAR(LB)
29900 NBAR(IB+1)=LB
30000 IF(JB.LT.MIN)GO TO 521
30100 JRN(IB)=JB
30200 GO TO 415
30300 521 IBB=IB-1
30400 LC=NBAR(IB)-1
30500 JB=JB+JBAR(LC)
30600 IF(JB.GT.MIN)GO TO 522
30700 JB=JB+JBAR(LC-1)
30800 NBAR(IB)=LC
30900 JRN(IBB)=JRN(IBB)-JBAR(LC)
31000 CHECK THIS OUT!!
31100 LC=LC-1
31200 522 JRN(IB)=JB
31300 JRN(IBB)=JRN(IBB)-JBAR(LC)
31400 NBAR(IB)=LC
31500 GO TO 415
31600 504 IF(J.LE.2)GO TO 502
31700 DO 506 N=J-1,2,-1
31800 LL=NBAR(N)-1
31900 MM=NN+JBAR(LL)
32000 IF(MM.GT.MX)GO TO 502
32100 IF(MM.GT.MIN)GO TO 509
32200 512 MN=MM+JBAR(LL-1)
32300 IF(MN.GT.MX)GO TO 502
32400 NN=JRN(N-1)-JBAR(LL)-JBAR(LL-1)
32500 IF(NN.GT.MIN)GO TO 505
32600 GO TO 506
32700 509 NN=JRN(N-1)-JBAR(LL)
32800 IF(NN.GE.MIN)GO TO 505
32900 506 CONTINUE
33000 502 IF(J.EQ.NJ.AND.MX-MN.EQ.LMM)GO TO 515
33100 C CHECK TO AVOID ENDLESS LOOP.
33200 NJ=J
33300 IF(J.EQ.JT)GO TO 515
33400 C LOOK FOR OTHER LINES = MIN.
33500 DO 510 K=J+1,JT
33600 IF(JRN(K).NE.MIN)GO TO 510
33700 J=K
33800 GO TO 408
33900 510 CONTINUE
34000
34100 515 CALL GET
34200
34300 13 DO 14 L=2,JT
34400 K=NBAR(L)
34500 MM=JRN(L)
34600 KK=JRN(L-1)
34700 IF(MM.GE.KK)GO TO 12
34800 C JUGGLES ADJACENT LINES
34900 N=JBAR(K-1)
35000 IF(KK-MM.LT.N)GO TO 14
35100 JRN(L-1)=KK-N
35200 JRN(L)=MM+N
35300 NBAR(L)=K-1
35400 GO TO 13
35500 12 N=JBAR(K)
35600 IF(MM-KK.LE.N)GO TO 14
35700 JRN(L-1)=KK+N
35800 JRN(L)=MM-N
35900 NBAR(L)=K+1
36000 GO TO 13
36100 14 CONTINUE
36200 46 J=1
36300 NBAR(JT+1)=KT+1
36400 JAV=JTOT/JT
36500 CALL MINMAX
36600 TYPE 308,JAV,MIN,MAX
36700 IF(DSK)WRITE(21,308)JAV,MIN,MAX
36800 307 DO 305 K=1,JT
36900 NBAR(K)=NBAR(K+1)-NBAR(K)
37000 C NBAR NOW HAS NUM. OF BARS PER LINE.
37100 L=NBAR(K)-1+J
37200 308 FORMAT(' AVG=',I3,' MIN=',I3,' MAX=',I3)
37300 306 FORMAT(I5,3X8I5)
37400 TYPE 306,JRN(K),(JBAR(N),N=J,L)
37500 IF(DSK)WRITE(21,306)JRN(K),(JBAR(N),N=J,L)
37600 305 J=L+1
37700 NBAR(JT+1)=0
37800
37900 RPG=JT
38000 RPG=RPG/MPG
38100 605 TYPE 604,RPG,JT
38200 IF(DSK)WRITE(21,104)RPG,JT
38300 604 FORMAT(F5.2,' PAGES',/,I4,' LINES - OR TYPE N1, N2 --'$)
38400 C FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
38500 KA=0
38600 ACCEPT 145,T,N,KL
38700 C TYPE 0,n TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
38800 IF(KL.NE.0)GO TO 110
38900 C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
39000 IF(T.EQ.0)GO TO 11
39100 JT=T
39200 IF(N.EQ.0)GO TO 16
39300 C N=0 MEANS T= NUM OF LINES DESIRED.
39400
39500 111 FORMAT(36I)
39600 110 REREAD 111,NBAR
39700 911 DO 112 K=36,1,-1
39800 KP=NBAR(K)
39900 KA=KA+KP
40000 112 IF(KP.EQ.0.AND.KA.EQ.0)KL=K
40100 IF(KA.NE.KT)GO TO 605
40200 C MISMATCH!
40300 N=26-2*MOD(KL-1,12)
40400 IF(N.EQ.26)N=0
40500 C TO SPACE OUT STAVES VERTICALLY
40600 CC IF(IPG)GO TO 11
40700 CC IF(NBAR(1).NE.0)GO TO 11
40800 CC DO 711 K=1,36
40900 CC IF(K.GT.J)IV(K)=0
41000 CC711 NBAR(K)=IV(K)
41100 CC GO TO 911
41200 11 CALL WRTPAG
41300 END
41400
41500 SUBROUTINE MINMAX
41600 COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
41700 MIN=10000
41800 MAX=0
41900 DO 107 K=1,JT
42000 NN=JRN(K)
42100 IF(NN.LT.MIN)MIN=NN
42200 107 IF(NN.GT.MAX)MAX=NN
42300 END
42400
42500 SUBROUTINE STORE
42600 COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)/NBAR/NBAR(1)
42700 DIMENSION MB(1)
42800 EQUIVALENCE (MB,JRN(1000))
42900 DO 1 K=2,JT+1
43000 1 MB(K)=NBAR(K)
43100 END
43200
43300 SUBROUTINE GET
43400 COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)/NBAR/NBAR(1)/KBAR/KBAR(1)
43500 DIMENSION MB(1),JBAR(1)
43600 EQUIVALENCE (MB,JRN(1000)),(JBAR,KBAR(4))
43700 J=1
43800 DO 1 K=2,JT+1
43900 NBAR(K)=MB(K)
44000 N=0
44100 DO 2 L=J,MB(K)-1
44200 C FIX UP JRN ARRAY
44300 2 N=N+JBAR(L)
44400 JRN(K-1)=N
44500 1 J=MB(K)
44600 END
44700
44800 SUBROUTINE MNMX(IDIF)
44900 COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
45000 L=MIN
45100 N=MAX
45200 CALL MINMAX
45300 J=MAX-MIN
45400 IF(J.LE.IDIF)GO TO 1
45500 MIN=L
45600 MAX=N
45700 RETURN
45800 1 IDIF=J
45900 END